home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / FileSys.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  5.5 KB  |  159 lines  |  [TEXT/Moml]
  1. (* FileSys -- 1995-06-16, 1995-09-25, 1996-05-01, 1996-10-13 *)
  2.  
  3. local 
  4.  
  5.     (* The type of directory structures, as handled by the OS: *)
  6.     prim_type dirstruct_; 
  7.  
  8.     (* Primitives from runtime/sys.c -- raise Io on error *)
  9.     prim_val chdir_  : string -> unit            = 1 "sys_chdir";
  10.     prim_val remove_ : string -> unit            = 1 "sys_remove";
  11.     prim_val rename_ : string -> string -> unit  = 2 "sys_rename";
  12.  
  13.     (* Primitives from runtime/mosml.c -- raise Fail on error *)
  14.     prim_val access_    : string -> int -> bool  = 2 "sml_access";
  15.     prim_val getdir_    : unit -> string         = 1 "sml_getdir"; 
  16.     prim_val isdir_     : string -> bool         = 1 "sml_isdir";
  17.     prim_val mkdir_     : string -> unit         = 1 "sml_mkdir";
  18.     prim_val tmpnam_    : unit -> string         = 1 "sml_tmpnam";
  19.     prim_val modtime_   : string -> real         = 1 "sml_modtime";
  20.     prim_val rmdir_     : string -> unit         = 1 "sml_rmdir";
  21.     prim_val settime_   : string -> real -> unit = 2 "sml_settime";
  22.     prim_val filesize_  : string -> int          = 1 "sml_filesize";
  23.  
  24.     prim_val opendir_   : string -> dirstruct_   = 1 "sml_opendir";
  25.     prim_val readdir_   : dirstruct_ -> string   = 1 "sml_readdir";
  26.     prim_val rewinddir_ : dirstruct_ -> unit     = 1 "sml_rewinddir";
  27.     prim_val closedir_  : dirstruct_ -> unit     = 1 "sml_closedir";
  28.  
  29.     fun formatErr mlOp (SOME operand) reason =
  30.         mlOp ^ " failed on `" ^ operand ^ "': " ^ reason
  31.       | formatErr mlOp NONE reason =
  32.         mlOp ^ " failed: " ^ reason
  33.  
  34.     (* Raise SysErr from ML function *)
  35.     fun raiseSysML mlOp operand reason =
  36.         raise SysErr (formatErr mlOp operand reason, NONE)
  37.  
  38.     (* Raise SysErr with OS specific explanation if errno <> 0 *)
  39.     fun raiseSys mlOp operand reason =
  40.         let prim_val errno_    : unit -> int        = 1 "sml_errno";
  41.             prim_val errormsg_ : int -> string      = 1 "sml_errormsg"; 
  42.             prim_val mkerrno_  : int -> OS.syserror = 1 "identity";
  43.             val errno = errno_ ()
  44.         in
  45.             if errno = 0 then raiseSysML mlOp operand reason
  46.             else raise SysErr 
  47.                 (formatErr mlOp operand (errormsg_ errno), 
  48.                  SOME (mkerrno_ errno))
  49.         end
  50. in
  51.  
  52.     type dirstream  = dirstruct_ option ref;
  53.     datatype access = A_READ | A_WRITE | A_EXEC;
  54.  
  55.     fun access (path, perm) =
  56.         let fun mem p = if List.exists (fn q => p=q) perm then 1 else 0
  57.             val permcode = mem A_READ + 2 * mem A_WRITE + 4 * mem A_EXEC
  58.         in 
  59.             (access_ path permcode) 
  60.             handle Fail s => raiseSys "access" (SOME path) s
  61.         end;
  62.  
  63.     fun getDir () =
  64.         (getdir_ ()) 
  65.         handle Fail s => raiseSys "getDir" NONE s;
  66.  
  67.     fun isDir p = 
  68.         (isdir_ p) handle Fail s => raiseSys "isDir" (SOME p) s;
  69.  
  70.     fun mkDir p = 
  71.         (mkdir_ p) handle Fail s => raiseSys "mkDir" (SOME p) s;
  72.  
  73.     fun chDir p =
  74.         (chdir_ p)
  75.         handle SysErr _ => raiseSys "chDir" (SOME p) "chdir";
  76.  
  77.     fun fullPath p =
  78.         let prim_val realpath_ : string -> string = 1 "sml_realpath"
  79.         in 
  80.             (realpath_ p) 
  81.             handle Fail s => raiseSys "fullPath" (SOME p) s 
  82.         end;
  83.  
  84.     fun isLink p =
  85.         let prim_val islink_ : string -> bool = 1 "sml_islink"
  86.         in (islink_ p) handle Fail s => raiseSys "isLink" (SOME p) s end;
  87.  
  88.     fun readLink p =
  89.         let prim_val readlink_ : string -> string = 1 "sml_readlink"
  90.         in (readlink_ p) handle Fail s => raiseSys "readLink" (SOME p) s end;
  91.  
  92.     type file_id = real;  (* Namely, 2^17 * device id  + inode number *)
  93.  
  94.     fun fileId p : file_id =
  95.         let prim_val devinode_ : string -> real = 1 "sml_devinode"
  96.         in (devinode_ p) handle Fail s => raiseSys "fileId" (SOME p) s end;
  97.  
  98.     fun hash (fid : file_id) = 
  99.         let prim_val hash_param : int -> int -> 'a -> word
  100.                                                 = 3 "hash_univ_param";
  101.         in hash_param 50 500 fid end;
  102.  
  103.     fun compare (fid1 : file_id, fid2) =
  104.         if fid1 < fid2 then LESS
  105.         else if fid1 > fid2 then GREATER
  106.         else EQUAL    
  107.  
  108.     fun realPath p =
  109.         if Path.isAbsolute p then fullPath p
  110.         else Path.mkRelative(fullPath p, getDir());
  111.  
  112.     fun rmDir p = 
  113.         (rmdir_ p) handle Fail s => raiseSys "rmDir" (SOME p) s;
  114.  
  115.     fun tmpName () =
  116.         (tmpnam_ ())
  117.         handle Fail s => raiseSys "tmpName" NONE s
  118.  
  119.     fun modTime p = 
  120.         (Time.fromReal (modtime_ p))
  121.         handle Fail s => raiseSys "modTime" (SOME p) s;
  122.  
  123.     fun fileSize p =
  124.         (filesize_ p) 
  125.         handle Fail s => raiseSys "fileSize" (SOME p) s;
  126.  
  127.     fun remove p = 
  128.         (remove_ p)
  129.         handle SysErr _ => raiseSys "remove" (SOME p) "unlink";
  130.  
  131.     fun rename {old, new} = 
  132.         (rename_ old new) 
  133.         handle SysErr _ => raiseSys "rename" (SOME old) "rename";
  134.  
  135.     fun setTime (path, time) =
  136.         let val tsec = 
  137.             Time.toReal (case time of NONE => Time.now() | SOME t => t)
  138.         in
  139.             (settime_ path tsec) 
  140.             handle Fail s => raiseSys "setTime" (SOME path) s
  141.         end;
  142.  
  143.     fun openDir path = 
  144.         (ref (SOME (opendir_ path)))
  145.         handle Fail s => raiseSys "openDir" (SOME path) s;
  146.  
  147.     fun readDir (ref NONE) = 
  148.         raiseSysML "readDir" NONE "Directory stream is closed"
  149.       | readDir (ref (SOME dstr)) = readdir_ dstr;
  150.  
  151.     fun rewindDir (ref NONE) =
  152.         raiseSysML "rewindDir" NONE "Directory stream is closed"
  153.       | rewindDir (ref (SOME dstr)) = rewinddir_ dstr;
  154.  
  155.     fun closeDir (ref NONE) = ()
  156.       | closeDir (r as ref (SOME dstr)) = 
  157.         (r := NONE; closedir_ dstr);
  158. end;
  159.